home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / pcl-rev4.lha / ibcl-low.lisp < prev    next >
Text File  |  1990-01-25  |  11KB  |  327 lines
  1. ;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; The version of low for Kyoto Common Lisp (KCL)
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; The reason these are here is because the KCL compiler does not allow
  32. ;;; LET to return FIXNUM values as values of (c) type int, hence the use
  33. ;;; of LOCALLY (which expands into (LET () (DECLARE ...) ...)) forces
  34. ;;; conversion of ints to objects.
  35. ;;; 
  36. (defmacro %logand (&rest args)
  37.   (reduce-variadic-to-binary 'logand args 0 t 'fixnum))
  38.  
  39. ;(defmacro %logxor (&rest args)
  40. ;  (reduce-variadic-to-binary 'logxor args 0 t 'fixnum))
  41.  
  42. (defmacro %+ (&rest args)
  43.   (reduce-variadic-to-binary '+ args 0 t 'fixnum))
  44.  
  45. ;(defmacro %- (x y)
  46. ;  `(the fixnum (- (the fixnum ,x) (the fixnum ,y))))
  47.  
  48. (defmacro %* (&rest args)
  49.   (reduce-variadic-to-binary '* args 1 t 'fixnum))
  50.  
  51. (defmacro %/ (x y)
  52.   `(the fixnum (/ (the fixnum ,x) (the fixnum ,y))))
  53.  
  54. (defmacro %1+ (x)
  55.   `(the fixnum (1+ (the fixnum ,x))))
  56.  
  57. (defmacro %1- (x)
  58.   `(the fixnum (1- (the fixnum ,x))))
  59.  
  60. (defmacro %svref (vector index)
  61.   `(svref (the simple-vector ,vector) (the fixnum ,index)))
  62.  
  63. (defsetf %svref (vector index) (new-value)
  64.   `(setf (svref (the simple-vector ,vector) (the fixnum ,index))
  65.          ,new-value))
  66.  
  67.  
  68. ;;;
  69. ;;; std-instance-p
  70. ;;;
  71. (si:define-compiler-macro std-instance-p (x)
  72.   (once-only (x)
  73.     `(and (si:structurep ,x)
  74.       (eq (si:structure-name ,x) 'std-instance))))
  75.  
  76. (dolist (inline '((si:structurep
  77.             ((t) compiler::boolean nil nil "type_of(#0)==t_structure")
  78.             compiler::inline-always)
  79.           (si:structure-name
  80.             ((t) t nil nil "(#0)->str.str_name")
  81.             compiler::inline-unsafe)))
  82.   (setf (get (first inline) (third inline)) (list (second inline))))
  83.  
  84. (setf (get 'cclosure-env 'compiler::inline-always)
  85.       (list '((t) t nil nil "(#0)->cc.cc_env")))
  86.  
  87. ;;;
  88. ;;; turbo-closure patch.  See the file kcl-mods.text for details.
  89. ;;;
  90. #+:turbo-closure
  91. (progn
  92. (CLines
  93.   "object tc_cc_env_nthcdr (n,tc)"
  94.   "object n,tc;                        "
  95.   "{return (type_of(tc)==t_cclosure&&  "
  96.   "         tc->cc.cc_turbo!=NULL&&    "
  97.   "         type_of(n)==t_fixnum)?     "
  98.   "         tc->cc.cc_turbo[fix(n)]:   " ; assume that n is in bounds
  99.   "         Cnil;                      "
  100.   "}                                   "
  101.   )
  102.  
  103. (defentry tc-cclosure-env-nthcdr (object object) (object tc_cc_env_nthcdr))
  104.  
  105. (setf (get 'tc-cclosure-env-nthcdr 'compiler::inline-unsafe)
  106.       '(((fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")))
  107. )
  108.  
  109.  
  110. ;;;; low level stuff to hack compiled functions and compiled closures.
  111. ;;;
  112. ;;; The primary client for this is fsc-low, but since we make some use of
  113. ;;; it here (e.g. to implement set-function-name-1) it all appears here.
  114. ;;;
  115.  
  116. (eval-when (compile eval)
  117.  
  118. (defmacro define-cstruct-accessor (accessor structure-type field value-type
  119.                         field-type tag-name)
  120.   (let ((setf (intern (concatenate 'string "SET-" (string accessor))))
  121.     (caccessor (format nil "pcl_get_~A_~A" structure-type field))
  122.     (csetf     (format nil "pcl_set_~A_~A" structure-type field))
  123.     (vtype (intern (string-upcase value-type))))
  124.     `(progn
  125.        (CLines ,(format nil "~A ~A(~A)                ~%~
  126.                              object ~A;               ~%~
  127.                              { return ((~A) ~A->~A.~A); }       ~%~
  128.                                                       ~%~
  129.                              ~A ~A(~A, new)           ~%~
  130.                              object ~A;               ~%~
  131.                              ~A new;                  ~%~
  132.                              { return ((~A)(~A->~A.~A = ~Anew)); } ~%~
  133.                             "
  134.             value-type caccessor structure-type 
  135.             structure-type
  136.             value-type structure-type tag-name field
  137.             value-type csetf structure-type
  138.             structure-type 
  139.             value-type 
  140.             value-type structure-type tag-name field field-type
  141.             ))
  142.  
  143.        (defentry ,accessor (object) (,vtype ,caccessor))
  144.        (defentry ,setf (object ,vtype) (,vtype ,csetf))
  145.  
  146.  
  147.        (defsetf ,accessor ,setf)
  148.  
  149.        )))
  150. )
  151. ;;; 
  152. ;;; struct cfun {                   /*  compiled function header  */
  153. ;;;         short   t, m;
  154. ;;;         object  cf_name;        /*  compiled function name  */
  155. ;;;         int     (*cf_self)();   /*  entry address  */
  156. ;;;         object  cf_data;        /*  data the function uses  */
  157. ;;;                                 /*  for GBC  */
  158. ;;;         char    *cf_start;      /*  start address of the code  */
  159. ;;;         int     cf_size;        /*  code size  */
  160. ;;; };
  161. ;;; add field-type tag-name
  162. (define-cstruct-accessor cfun-name  "cfun" "cf_name"  "object" "(object)" "cf")
  163. (define-cstruct-accessor cfun-self  "cfun" "cf_self"  "int" "(int (*)())" 
  164.                          "cf")
  165. (define-cstruct-accessor cfun-data  "cfun" "cf_data"  "object" "(object)" "cf")
  166. (define-cstruct-accessor cfun-start "cfun" "cf_start" "int" "(char *)" "cf")
  167. (define-cstruct-accessor cfun-size  "cfun" "cf_size"  "int" "(int)" "cf")
  168.  
  169. (CLines
  170.   "object pcl_cfunp (x)              "
  171.   "object x;                         "
  172.   "{if(x->c.t == (int) t_cfun)       "
  173.   "  return (Ct);                    "
  174.   "  else                            "
  175.   "    return (Cnil);                "
  176.   "  }                               "
  177.   )
  178.  
  179. (defentry cfunp (object) (object pcl_cfunp))
  180.  
  181. ;;; 
  182. ;;; struct cclosure {               /*  compiled closure header  */
  183. ;;;         short   t, m;
  184. ;;;         object  cc_name;        /*  compiled closure name  */
  185. ;;;         int     (*cc_self)();   /*  entry address  */
  186. ;;;         object  cc_env;         /*  environment  */
  187. ;;;         object  cc_data;        /*  data the closure uses  */
  188. ;;;                                 /*  for GBC  */
  189. ;;;         char    *cc_start;      /*  start address of the code  */
  190. ;;;         int     cc_size;        /*  code size  */
  191. ;;; };
  192. ;;; 
  193. (define-cstruct-accessor cclosure-name "cclosure"  "cc_name"  "object"
  194.                          "(object)" "cc")          
  195. (define-cstruct-accessor cclosure-self "cclosure"  "cc_self"  "int" 
  196.                          "(int (*)())" "cc")
  197. (define-cstruct-accessor cclosure-data "cclosure"  "cc_data"  "object"
  198.                           "(object)" "cc")
  199. (define-cstruct-accessor cclosure-start "cclosure" "cc_start" "int" 
  200.                          "(char *)" "cc")
  201. (define-cstruct-accessor cclosure-size "cclosure"  "cc_size"  "int"
  202.              "(int)" "cc")
  203. (define-cstruct-accessor cclosure-env "cclosure"   "cc_env"   "object"
  204.                          "(object)" "cc")
  205.  
  206.  
  207. (CLines
  208.   "object pcl_cclosurep (x)          "
  209.   "object x;                         "
  210.   "{if(x->c.t == (int) t_cclosure)   "
  211.   "  return (Ct);                    "
  212.   "  else                            "
  213.   "   return (Cnil);                 "
  214.   "  }                               "
  215.   )
  216.  
  217. (defentry cclosurep (object) (object pcl_cclosurep))
  218.  
  219.   ;;   
  220. ;;;;;; Load Time Eval
  221.   ;;
  222. ;;; 
  223.  
  224. ;;; This doesn't work because it looks at a global variable to see if it is
  225. ;;; in the compiler rather than looking at the macroexpansion environment.
  226. ;;; 
  227. ;;; The result is that if in the process of compiling a file, we evaluate a
  228. ;;; form that has a call to load-time-eval, we will get faked into thinking
  229. ;;; that we are compiling that form.
  230. ;;;
  231. ;;; THIS NEEDS TO BE DONE RIGHT!!!
  232. ;;; 
  233. ;(defmacro load-time-eval (form)
  234. ;  ;; In KCL there is no compile-to-core case.  For things that we are 
  235. ;  ;; "compiling to core" we just expand the same way as if were are
  236. ;  ;; compiling a file since the form will be evaluated in just a little
  237. ;  ;; bit when gazonk.o is loaded.
  238. ;  (if (and (boundp 'compiler::*compiler-input*)  ;Hack to see of we are
  239. ;       compiler::*compiler-input*)          ;in the compiler!
  240. ;      `'(si:|#,| . ,form)
  241. ;      `(progn ,form)))
  242.  
  243. (defmacro load-time-eval (form)
  244.   (read-from-string (format nil "'#,~S" form)))
  245.  
  246. (defmacro memory-block-ref (block offset)
  247.   `(svref (the simple-vector ,block) (the fixnum ,offset)))
  248.  
  249.   ;;   
  250. ;;;;;; Generating CACHE numbers
  251.   ;;
  252. ;;; This needs more work to be sure it is going as fast as possible.
  253. ;;;   -  The calls to si:address should be open-coded.
  254. ;;;   -  The logand should be open coded.
  255. ;;;   
  256.  
  257. ;(defmacro symbol-cache-no (symbol mask)
  258. ;  (if (and (constantp symbol)
  259. ;       (constantp mask))
  260. ;      `(load-time-eval (logand (ash (si:address ,symbol) -2) ,mask))
  261. ;      `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
  262.  
  263. (defmacro object-cache-no (object mask)
  264.   `(logand (the fixnum (si:address ,object)) ,mask))
  265.  
  266.   ;;   
  267. ;;;;;; printing-random-thing-internal
  268.   ;;
  269. (defun printing-random-thing-internal (thing stream)
  270.   (format stream "~O" (si:address thing)))
  271.  
  272.  
  273. (defun set-function-name-1 (fn new-name ignore)
  274.   (cond ((cclosurep fn)
  275.      (setf (cclosure-name fn) new-name))
  276.     ((cfunp fn)
  277.      (setf (cfun-name fn) new-name))
  278.     ((and (listp fn)
  279.           (eq (car fn) 'lambda-block))
  280.      (setf (cadr fn) new-name))
  281.     ((and (listp fn)
  282.           (eq (car fn) 'lambda))
  283.      (setf (car fn) 'lambda-block
  284.            (cdr fn) (cons new-name (cdr fn)))))
  285.   fn)
  286.  
  287.  
  288.  
  289.  
  290. #|
  291. (defconstant most-positive-small-fixnum 1024)  /* should be supplied */
  292. (defconstant most-negative-small-fixnum -1024) /* by ibuki */
  293.  
  294. (defmacro symbol-cache-no (symbol mask)
  295.   (if (constantp mask)
  296.       (if (and (> mask 0)
  297.            (< mask most-positive-small-fixnum))
  298.       (if (constantp symbol)
  299.           `(load-time-eval (coffset ,symbol ,mask 2))
  300.         `(coffset ,symbol ,mask 2))
  301.     (if (constantp symbol)
  302.         `(load-time-eval 
  303.            (logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))
  304.       `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
  305.     `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
  306.  
  307.  
  308. (defmacro object-cache-no (object mask)
  309.   (if (and (constantp mask)
  310.        (> mask 0)
  311.        (< mask most-positive-small-fixnum))
  312.       `(coffset ,object ,mask 4)
  313.     `(logand (ash (the fixnum (si:address ,object)) -4) ,mask)))
  314.  
  315. (CLines
  316.   "object pcl_coffset (sym,mask,lshift)"
  317.   "object sym,mask,lshift;"
  318.   "{"
  319.   "    return(small_fixnum(((int)sym >> fix(lshift)) & fix(mask)));"
  320.   "}"
  321.   )
  322.  
  323. (defentry coffset (object object object) (object pcl_coffset))
  324.  
  325.  
  326. |#
  327.